package Template5::Encoding;
use strict;
use warnings;

use HTML::Parser qw();
use Text::Iconv;
use Encode;

use base qw(Exporter);

our $VERSION = '0.52';

our @EXPORT_OK =
qw/
    &encoding_from_meta_element
    &xml_declaration_from_octets
    &encoding_from_first_chars
    &encoding_from_xml_declaration
    &encoding_from_byte_order_mark
    &encoding_from_content_type
    &encoding_from_xml_document
/;

our $DEFAULT_ENCODINGS = [qw/
  ISO-8859-1
  UTF-16LE
  UTF-16BE
  UTF-8
  UTF-7
/];

our %MAP =
(
    BM => "\x{FEFF}",
    CR => "\x{000D}",
    LF => "\x{000A}",
    SP => "\x{0020}",
    TB => "\x{0009}",
    QS => "\x{003F}",
    NL => "\x{0085}",
    LS => "\x{2028}",
    LT => "<", # fixme
    GT => ">", # fixme
);

sub my_encode
{
    my $encoding = shift;
    my $string = shift;
    my $check = shift;
    
    my $seq;
    my $converter = Text::Iconv->new('latin1', $encoding);
    
    eval
    {
        $seq = $converter->convert($string);
    };
    
    return $seq unless $@;
    return;
}

sub my_decode
{
    my $encoding = shift;
    my $octets = shift;
    my $check = shift;
    
    my $str;
    my $converter = Text::Iconv->new($encoding, 'latin1');
    
    eval
    {
        $str = $converter->convert($octets);
    };
    
    return $str unless $@;
    return;
}

sub make_character_map
{
    my $encoding = shift;
    my %data;
    
    foreach my $sym (keys %MAP)
    {
        my $seq = my_encode($encoding, $MAP{$sym}, Encode::FB_CROAK);
        $data{$sym} = $seq if defined $seq;
    }
    
    \%data;
}

# cache for U+XXXX octet sequences
our %CHARACTER_MAP_CACHE = ();

sub get_character_map
{
    my $encoding = shift;
    
    # read from cache
    return $CHARACTER_MAP_CACHE{$encoding} if exists $CHARACTER_MAP_CACHE{$encoding};
    
    # new cache entry
    my $map = make_character_map($encoding);
    $CHARACTER_MAP_CACHE{$encoding} = $map;
    
    # return new entry
    return $map;
}

sub xml_declaration_from_octets
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;
    
    return unless defined $text;
    return unless length $text;

    foreach my $e (@$encodings)
    {    
        my $map = get_character_map($e);
        
        # search for >
        my $end = index $text, $map->{GT};

        # search for <
        my $str = index $text, $map->{LT};
        
        # skip this encoding unless ...
        next unless $end > 0 and $str >= 0 and $end > $str;

        # extract tentative XML declaration
        my $decl = substr $text, $str, $end - $str + length($map->{GT});
        
        # decode XML declaration
        my $deco = my_decode($e, $decl, Encode::FB_CROAK);
        
        # skip encoding if decoding failed
        next unless defined $deco;
        
        $resu{$deco}++;
    }
    
    # No XML declarations found
    return unless keys %resu;

    # sort by number of matches, most match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;
    
    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_first_chars
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my $whitespace = $o{whitespace} || [qw/CR LF TB SP/];

    return unless defined $text;
    return unless length $text;
    
    my %resu;
    foreach my $e (@$encodings)
    {
        my $m = get_character_map($e);
        my $i = index $text, $m->{LT};
        next unless $i >= 0;
        my $t = substr $text, 0, $i;
        
        my @y;

        # construct \xXX\xXX string from octets, might make sense to
        # have this in the map construction process
        push@y,"(?:".join("",map{sprintf"\\x%02x",ord}split//,$m->{$_}).")"
          foreach grep defined, @$whitespace;

        my $x = join "|", @y;
        $t =~ s/^($x)+//g;
        
        $resu{$e} = $i + length $m->{LT} unless length $t;
    }
    
    # ...
    return unless keys %resu;
    
    # sort by match length, longest match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;
    
    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_xml_declaration
{
    my $decl = shift;

    return unless defined $decl;
    return unless length $decl;

    # todo: move this to some better place...
    my $ws = qr/[\x09\x85\x20\x0d\x0a\x{2028}]*/;
    
    # attempt to extract encoding pseudo attribute
    return unless $decl =~ /encoding$ws=$ws'([^']+)'/i or
                  $decl =~ /encoding$ws=$ws"([^"]+)"/i;

    # no encoding pseudo-attribute
    return unless defined $1;
    my $enco = $1;

    # strip leading/trailing whitespace/quotes
    $enco =~ s/^[\s'"]+|[\s'"]+$//g;
    
    # collapse white-space
    $enco =~ s/\s+/ /g;
    
    # treat empty charset as if it were unspecified
    return unless length $enco;

    return $enco;
}

sub encoding_from_byte_order_mark
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;

    return unless defined $text;
    return unless length $text;

    foreach my $e (@$encodings)
    {
        my $map = get_character_map($e);
        my $bom = $map->{BM};
        
        # encoding cannot encode U+FEFF
        next unless defined $bom;
        
        # remember match length
        $resu{$e} = length $bom if $text =~ /^(\Q$bom\E)/;
    }

    # does not start with BOM
    return unless keys %resu;
    
    # sort by match length, longest match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;
    
    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_xml_document
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;
    
    return unless defined $text;
    return unless length $text;
    
    my @boms = encoding_from_byte_order_mark($text, encodings => $encodings);

    # BOM determines encoding
    return wantarray ? (bom => \@boms) : $boms[0] if @boms;
    
    # no BOM
    my @decls = xml_declaration_from_octets($text, encodings => $encodings);
    foreach my $decl (@decls)
    {
        my $enco = encoding_from_xml_declaration($decl);
        $resu{$enco}++ if defined $enco and length $enco;
    }

    return unless keys %resu;
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;
    
    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? (xml => \@sort) : $sort[0];
};

1;
